;; This file is part of Kato Javascript Framework (http://kato.googlecode.com/)
;;
;; Copyright (c) 2007, Filip Dreger, Jan Urbański
;; Copyright (c) 2008, Daniel Janus
;;
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;;     * Redistributions of source code must retain the above copyright
;;       notice, this list of conditions and the following disclaimer.
;;     * Redistributions in binary form must reproduce the above
;;       copyright notice, this list of conditions and the following
;;       disclaimer in the documentation and/or other materials provided
;;       with the distribution.
;;     * Neither the name of Kato Javascript Framework nor the names
;;       of its contributors may be used to endorse or promote products
;;       derived from this software without specific prior written
;;       permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;
;; This highly experimental backend for Kato requires Postmodern
;; (with an open connection) and a hacked version of CL-JSON
;; to interpret JSON null value as :NULL symbol instead of NIL.
;; Missing features, ASDF system definition, etc., coming soon.

(defpackage #:kato
  (:use #:cl #:iterate #:postmodern #:hunchentoot #:json #:json-rpc))

(in-package #:kato)

(defparameter *kato-tables*
  (mapcar #'first
          (query (:select 'tablename
                  :from 'pg_tables
                  :where (:= 'schemaname "public")))))

(defun get-primary-key (table &optional numbers)
  (let ((columns (query (:select 'indkey
                         :from (:as 'pg_index 'i)
                         :left-join (:as 'pg_class 'c) :on (:= 'i.indrelid 'c.oid)
                                                       :where (:and 'indisprimary
                                                                    (:= 'relname table)))))
        (tableid (parse-integer (query (:select 'oid
                                        :from 'pg_class
                                        :where (:= 'relname table))
                                       :single))))
    (when columns
      (setf columns (mapcar #'parse-integer (split-sequence:split-sequence #\Space (caar columns)))))
    (unless columns
      (setf columns (list 1)))
    (when numbers
      (return-from get-primary-key columns))
    (mapcar (lambda (column)
              (query (:select 'attname
                              :from 'pg_attribute
                              :where (:and (:= 'attrelid tableid)
                                           (:= 'attnum column)))
                     :single))
            columns)))

(defparameter *kato-type-map*
  '(("int4" . "int")
    ("text" . "text")
    ("numeric" . "numeric")
    ("timestamp" . "timestamp")))

(defun table-header-internal (table)  
  (query (:select 'attname 'attnotnull 'typname 'atthasdef
                  :from (:as 'pg_attribute 'a)
                  :inner-join (:as 'pg_class 'c) :on (:= 'c.oid 'a.attrelid)
                  :inner-join (:as 'pg_type 'typ) :on (:= 'typ.oid 'a.atttypid)
                  :where (:and (:= 'c.relname table)
                               (:> 'a.attnum 0)))))

(defun get-table-header (table)
  (let ((result (table-header-internal table))
        (primary-keys (get-primary-key table)))
    (iter (for (name notnull typename default) in result)
          (for num from 1)
          (collect `(("num" . ,num)
                     ("type" . ,(cdr (assoc typename *kato-type-map* :test #'equal)))
                     ("column" . ,name)
                     ("not null" . ,notnull)
                     ("len" . "not yet supported")
                     ("primary position" . ,(if (member name primary-keys :test #'equal) num :null))
                     ("has default" . ,default))))))

(defun canonicalize-primary-key (keys)
  (format nil "~{~a~^!~}" keys))

(defun-json-rpc get_primary_keys (arg)
  (declare (ignore arg))
  (list (cons "primary_keys" 
              (iter (for table in *kato-tables*)
                    (collect (cons (canonicalize-primary-key (get-primary-key table))
                                   table))))))

(defun split-criterion (criterion)
  (multiple-value-bind (op index) (split-sequence:split-sequence #\_ criterion :count 1)
    (values (first op) (subseq criterion index))))    

(defparameter *where-operation-map* 
  '(("search" . :=)
    ("rregexp" . :~)
    ("ge" . :>=)
    ("gt" . :>)
    ("lt" . :<)
    ("le" . :<=)))

(defparameter *where-criteria*
  (append '("rregexp" "ilike" "isnull")
          (mapcar #'car *where-operation-map*)))

(defun criterion-name (criterion)
  (split-criterion (car criterion)))

(defun sqlize-where-criterion (criterion)
  (destructuring-bind (opcolumn . value) criterion
    (multiple-value-bind (op column) (split-criterion opcolumn)
      (cond
        ((find op *where-operation-map* :key #'car :test #'equal)
         (list (cdr (assoc op *where-operation-map* :test #'equal))
               (make-symbol column)
               value))
        ((string= op "isnull")
         `(:is-null ,(make-symbol column)))
        (t
         `(:like ,(make-symbol column) ,(format nil "%~A%" value)))))))

(defun find-limit (criteria)
  (values (iter (for x in criteria) 
                (when (string= (criterion-name x) "limit")
                  (leave (cdr x))))
          (iter (for x in criteria)
                (when (string= (criterion-name x) "offset")
                  (leave (cdr x))))))

(defun find-order-by (criteria)
  (iter (for x in criteria)
        (multiple-value-bind (op column) (split-criterion (car x))
          (when (string= op "orderby")
            (if (equalp (cdr x) "desc")
                (collect `(:desc ,(make-symbol column)))
                (collect (make-symbol column)))))))

(defun wrap-limit (criteria query)
  (multiple-value-bind (limit offset) (find-limit criteria)
    (if limit
        (list :limit query limit offset)
        query)))

(defun wrap-order-by (criteria query)
  (let ((order-by (find-order-by criteria)))
    (if order-by
        `(:order-by ,query ,@order-by)
        query)))

(defun sqlize-where-criteria (criteria)
  (let ((criteria
         (iter (for x in criteria)
               (when (and (member (criterion-name x) *where-criteria* :test #'string=)
                          (cdr x))
                 (collect (sqlize-where-criterion x))))))
    (if criteria 
        `(:and ,@criteria)
        t)))

(defun make-query (table criteria)
  (iter (for x in criteria)
        (setf (car x)
              (string-downcase (princ-to-string (car x)))))
  (wrap-limit criteria
              (wrap-order-by criteria
                             `(:select :*
                                       :from ,(make-symbol table)
                                       :where ,(sqlize-where-criteria criteria)))))

(defun-json-rpc get_data (table criteria hints)
  (declare (ignorable hints))
  (let ((header (get-table-header table)))
    `((:head . ((:revision . "0")))
      (:columns . ,header)
      (:rows . ,(or (query (sql-compile (make-query table criteria))) (vector))))))

(defun make-insert (table row)
  (let ((keys (get-primary-key table t)))
    `(:insert-into 
      ,(make-symbol table)
      :set
      ,@(iter (for i from 1)
              (for x in row)
              (for col in (table-header-internal table))
              (unless (member i keys)
                (collect (make-symbol (first col)))
                (collect x))))))    

(defun make-update (table row)
  (let ((keys (get-primary-key table t)))
    `(:update
      ,(make-symbol table)
      :set
      ,@(iter (for i from 1)
              (for x in row)
              (for col in (table-header-internal table))
              (unless (member i keys)
                (collect (make-symbol (first col)))
                (collect x)))
      :where (:and
              ,@(iter (for i from 1)
                      (for x in row)
                      (for col in (table-header-internal table))
                      (when (member i keys)
                        (collect `(:= ,(make-symbol (first col)) ,x))))))))

(defun make-delete (table row)
  (let ((keys (get-primary-key table t)))
    `(:delete-from
      ,(make-symbol table)
      :where (:and
              ,@(iter (for i from 1)
                      (for x in row)
                      (for col in (table-header-internal table))
                      (when (member i keys)
                        (collect `(:= ,(make-symbol (first col)) ,x))))))))  

(defun execute-operation (table operation hints)
  (when (assoc :try_only hints)
    (return-from execute-operation t))
  (let ((cmd (cdr (assoc :command operation)))
        (row (cdr (assoc :row operation))))
    (execute (sql-compile (funcall (intern (concatenate 'string "MAKE-" (string-upcase cmd)))
                                   table row)))))

(defun-json-rpc do_operations (table operations hints)
  (dolist (operation operations)
    (execute-operation table operation hints))
  :null)

(define-easy-handler (kato :uri "/kato") ()
  (invoke-rpc (raw-post-data :external-format :utf-8)))